home *** CD-ROM | disk | FTP | other *** search
/ Technotools / Technotools (Chestnut CD-ROM)(1993).ISO / lang_oth / ada / aterp.pas < prev    next >
Pascal/Delphi Source File  |  1986-01-05  |  35KB  |  934 lines
  1. Program Aug_Terp;
  2. {  Aug_Terp is an interpreter for Augusta, the public domain compiler }
  3. { which translates a subset of Ada into pseudo-code. The p-code is the }
  4. { source for Aug_Terp. See Dr. Dobb's Journal numbers 75,77,79,81 for }
  5. { extensive documentation. }
  6.  
  7. Const
  8.   terp_version = '1.2';
  9.   system_size  = 16;     { 8 or 16 bit machine for heap size calculations }
  10.   nl           = #13#10; { characters to start a new line }
  11.   buflen       = 512;    { MUST be a multiple of 128 }
  12.   buf_max      = 511;    { (buflen-1) for use in buffer indexing }
  13.   page_limit   = 63;     { highest legal page number (32k/buflen) }
  14. Type
  15.   str_ptr_type = ^anystring;
  16.   anystring    = string[255];
  17.   buf_pointer  = ^buf_type;
  18.   buf_type     = record
  19.                    data: array[0..buf_max] of byte;
  20.                    next: buf_pointer;
  21.                  end;
  22. Var
  23.  { The virtual machine }
  24.   CP     : integer; { p-code instruction pointer }
  25.   SP     : integer; { stack pointer }
  26.   GF     : integer; { global frame pointer }
  27.   LF     : integer; { local frame pointer }
  28.   SB     : integer; { stack base (points to the bottom of the stack)}
  29.   CB     : integer; { points to the 1st code byte in current proc.}
  30.   CS     : integer; { code segment (points to the first byte of code)}
  31.   PN     : integer; { number of current proc. }
  32.  
  33.   header    : record
  34.                 code_size  : integer; { code size in bytes }
  35.                 max_record : integer; { # of 128-byte records in the file }
  36.                 max_proc   : integer; { # of procedures }
  37.                 version    : integer; { code file version number }
  38.               end;
  39.   proctable : array[1..256] of record
  40.                 offset          : integer; { offset from CS to proc code }
  41.                 local_var_bytes : integer; { # bytes needed for local vars }
  42.                 parm_bytes      : integer; { # bytes needed for parameters }
  43.                 level           : byte;    { lexical level of the procedure }
  44.               end;
  45.   page             : array[0..page_limit] of buf_pointer;
  46.   max_mem,max_page : integer;   { maximum buffer and page indexes }
  47.   code_file        : file;      { used for the p-code file I/O }
  48.   work_string      : anystring; { a work variable for string operations }
  49.  
  50.  
  51. Procedure Error(err_num,value: integer);
  52. { handles errors consistently, giving appropriate state info w/ the message. }
  53. begin
  54.   write(nl,'aug-> ');
  55.   case err_num of
  56.     1: write('Read offset ',value,' out of range');
  57.     2: write('Write offset ',value,' out of range');
  58.     3: write('Too many pages with ',value,' bytes allocated');
  59.     4: write('Out of memory with ',value,' bytes in use');
  60.     5: write('Integer multiplication overflow');
  61.     6: write('Integer division overflow');
  62.     7: write('Call to unimplemented system procedure ',value);
  63.     8: write('Illegal op-code ',value);
  64.     9: begin
  65.          write('Unable to open ');
  66.          if value<0 then begin
  67.            writeln(paramstr(1)); halt; end
  68.          else write('#',value);
  69.        end;
  70.   end;
  71.   writeln(' at PN=',PN,' CP=',CP,' SP=',SP);
  72.   halt;
  73. end;
  74.  
  75. Function Mem_Avail: real;
  76. { returns the free heap space }
  77. const
  78.   system_size = 16; { either 8 or 16 bit system }
  79. var
  80.   X : real;
  81. begin
  82.   X := Maxavail;
  83.   if X<0 then X := X + 65536.0;
  84.   if system_size=16 then X := X * 16.0;
  85.   Mem_avail := X;
  86. end;
  87.  
  88.  
  89. Procedure Load_Program;
  90. { gets the name of the p-code file, loads it into memory and initializes }
  91. {  the virtual machine.  }
  92. var
  93.   file_as_byte : file of byte;{ typed file to allow read()'ing header }
  94.   name         : string[32];  { filename }
  95.   recs_per_buf : integer;     { number of 128-byte records in a buffer }
  96.   temp1,temp2  : byte;        { local work variables }
  97.   temp3,temp4  : byte;
  98.   I            : integer;
  99. begin
  100.   { present the intro screen }
  101.   clrscr; writeln('A u g  -  T e r p',nl,'Version ',terp_version);
  102.  
  103.   { get the filename from the command line and make sure it's available }
  104.   if paramcount<>1 then begin
  105.     write(nl,'Usage: ATERP filename');
  106.     halt; end
  107.   else begin
  108.     name := paramstr(1);
  109.     {$I-} assign(file_as_byte,name); reset(file_as_byte); {$I+}
  110.     if IOResult<>0 then error(9,-1);
  111.   end;
  112.  
  113.   { load the header block and make sure it's an augusta code file }
  114.   with header do begin
  115.     read(file_as_byte, temp1,temp2,temp3,temp4);
  116.     code_size := temp2*256 + temp1 - 1920;
  117.     max_record := temp4*256 + temp3;
  118.     read(file_as_byte, temp1,temp2,temp3,temp4);
  119.     max_proc := temp2*256 + temp1; version := temp4*256 + temp3;
  120.   end;
  121.   read(file_as_byte, temp1,temp2,temp3,temp4);
  122.   if not ((temp1=89) and (temp2=4) and (temp3=0) and (temp4=0))
  123.      or (filesize(file_as_byte)<1921) then begin
  124.     writeln(name,' is not a valid Augusta p-code file.');
  125.     halt; end
  126.  
  127.   { read in only as many proc table entries as the header says exist }
  128.   else begin
  129.     writeln('Loading ...');
  130.     seek(file_as_byte,128);{ skip 116 unused header bytes to the proc table}
  131.     for I:=1 to header.max_proc do
  132.       with proctable[i] do begin
  133.         read(file_as_byte, temp1,temp2,temp3,temp4);
  134.         offset := (temp2 shl 8) + temp1;
  135.         local_var_bytes := (temp4 shl 8) + temp3;
  136.         read(file_as_byte, temp1,temp2,level);
  137.         parm_bytes := (temp2 shl 8) + temp1;
  138.       end;
  139.   end;
  140.   close(file_as_byte);
  141.  
  142.   { reopen the file as untyped, with an implied 128-byte record length }
  143.   assign(code_file,name); reset(code_file);
  144.  
  145.   { make sure there is enough memory to load the whole file. the    }
  146.   { heap_space calculations account for 8 or 16 bit Turbo versions. }
  147.   if mem_avail<(header.code_size + 1000) then begin
  148.     writeln(nl,'Not enough free memory.  Only ',mem_avail:6:0,
  149.       ' bytes are available.');
  150.     close(code_file);
  151.     halt; end
  152.   else begin
  153.     { read the code into a linked list of buffers. on exit max_page is the }
  154.     { highest legal sequential buffer (the first being #0), and the link   }
  155.     { pointer for the last buffer is set to nil. }
  156.     seek(code_file,15); { skip to the code area }
  157.     max_page := -1; max_mem := -1;
  158.     recs_per_buf := buflen div 128;
  159.     repeat
  160.       max_page := max_page + 1;
  161.       getmem(page[max_page],sizeof(buf_type));
  162.       blockread(code_file,page[max_page]^.data,recs_per_buf,I);
  163.       if I=0 then
  164.         max_page := max_page - 1
  165.       else begin
  166.         max_mem := max_mem + I*buflen;
  167.         if max_page>0 then page[max_page-1]^.next := page[max_page];
  168.       end;
  169.       if max_page>page_limit then error(3,max_mem);
  170.     until I<recs_per_buf;
  171.     close(code_file);
  172.  
  173.     { get two extra buffers for initial stack space }
  174.     for I:=1 to 2 do begin
  175.       max_page := max_page + 1;
  176.       if max_page>page_limit then error(3,max_mem);
  177.       getmem(page[max_page],sizeof(buf_type));
  178.       page[max_page-1]^.next := page[max_page];
  179.     end;
  180.     page[max_page]^.next := nil;
  181.   end;
  182.   clrscr;
  183. end;
  184.  
  185. Function Get_byte(var offset: integer): byte;
  186. { gets the byte at Offset and increments Offset to the next byte. if  }
  187. { the offset is out of allocated memory range, call error (and halt). }
  188. var
  189.   page_num,pos: integer;
  190. begin
  191.   if (offset>max_mem) or (offset<0) then error(1,offset);
  192.  
  193.   { page_num is the buffer the byte is in, pos is the offset in that buffer }
  194.   page_num := offset div buflen; pos := offset mod buflen;
  195.   offset := offset + 1; Get_byte := page[page_num]^.data[pos];
  196. end;
  197.  
  198. Function Get_Word(offset: integer): integer;
  199. { gets the word at Offset, leaving Offset as it was on entry. call error }
  200. { if offset is out of range. }
  201. var
  202.   page_num,pos,K: integer;
  203. begin
  204.   if (offset>=max_mem) or (offset<0) then error(1,offset);
  205.  
  206.   { page_num is the buffer the 1st byte is in, pos is the offset into it }
  207.   page_num := offset div buflen; pos := offset mod buflen;
  208.   K := page[page_num]^.data[pos];
  209.   if pos=buf_max then begin
  210.     page_num := page_num + 1;
  211.     pos := 0; end
  212.   else pos := pos + 1;
  213.   get_word := (page[page_num]^.data[pos] shl 8) + K;
  214. end;
  215.  
  216. Procedure Put_Word(offset,data: integer);
  217. { moves Data into memory word at offset, allocating more memory if necessary }
  218. var
  219.   page_num,pos : integer;
  220. begin
  221.   if offset<0 then
  222.     error(2,offset)
  223.   else begin
  224.     while (offset>max_mem-1) do
  225.       if mem_avail<sizeof(buf_type) then
  226.         error(4,max_mem)
  227.       else begin
  228.         max_page := max_page + 1;
  229.         if max_page>page_limit then error(3,max_mem);
  230.         getmem(page[max_page],sizeof(buf_type));
  231.         page[max_page-1]^.next := page[max_page];
  232.         page[max_page]^.next := nil;
  233.         max_mem := max_mem + buflen;
  234.       end;
  235.   end;
  236.  
  237.   { page_num is the buffer the 1st byte is in, pos is the offset into it }
  238.   page_num := offset div buflen; pos := offset mod buflen;
  239.   page[page_num]^.data[pos] := (data and 255);
  240.   if pos=buf_max then begin
  241.     page_num := page_num + 1;
  242.     pos := 0; end
  243.   else pos := pos + 1;
  244.   page[page_num]^.data[pos] := (data shr 8);
  245. end;
  246.  
  247. Procedure Put_Byte(offset: integer; data: byte);
  248. { moves Data into memory byte at offset, allocating more buffers if need be }
  249. var
  250.   page_num,pos: integer;
  251. begin
  252.   if offset<0 then
  253.     error(2,offset)
  254.   else begin
  255.     while (offset>max_mem) do
  256.       if mem_avail<sizeof(buf_type) then
  257.         error(4,max_mem)
  258.       else begin
  259.         max_page := max_page + 1;
  260.         if max_page>page_limit then error(3,max_mem);
  261.         getmem(page[max_page],sizeof(buf_type));
  262.         page[max_page-1]^.next := page[max_page];
  263.         page[max_page]^.next := nil;
  264.         max_mem := max_mem + buflen;
  265.       end;
  266.   end;
  267.  
  268.   { page_num is the buffer the 1st byte is in, pos is the offset into it }
  269.   page_num := offset div buflen; pos := offset mod buflen;
  270.   page[page_num]^.data[pos] := (data and 255);
  271. end;
  272.  
  273. Function Get_Str_Ptr(offset : integer): str_ptr_type;
  274. { returns a pointer to a string at Offset. If the string crosses a }
  275. { buffer boundary, it is copied to Work_String and the pointer }
  276. { points there. This avoids the non-program info between buffers. }
  277. { Note: the string pointed to by the result should be copied before }
  278. { calling Get_str_ptr again, as Work_string may be used for both. }
  279. var
  280.   P,Index,L  : integer;      { buffer page & offset, string length }
  281.   T1,T2      : integer;      { temporary vars }
  282.   work_ptr   : str_ptr_type;
  283. begin
  284.   P := offset div buflen; Index := offset mod buflen;
  285.   { if the offset is too big call read error }
  286.   if P>max_page then error(1,offset);
  287.  
  288.   { else point work_ptr at the string }
  289.   work_ptr := ptr(seg(page[P]^.data[index]),ofs(page[P]^.data[index]));
  290.   L := length(work_ptr^);
  291.   if (index+L)>buf_max then begin
  292.     { if it crosses a boundary, Copy the 1st part and Get_byte the 2nd, }
  293.     { then point to the finished copy. }
  294.     work_string := copy(work_ptr^,1,buf_max-index);
  295.     L := L - buf_max + index; offset := offset + buf_max - index + 1;
  296.     for T1:=L downto 1 do begin
  297.       T2 := get_byte(offset); work_string := work_string + chr(T2);
  298.     end;
  299.     work_ptr := ptr(seg(work_string),ofs(work_string));
  300.   end;
  301.   Get_Str_Ptr := work_ptr;
  302. end;
  303.  
  304. Procedure Store_Str(offset : integer; st : anystring);
  305. { stores St at Offset, accounting for boundary crossings }
  306. var
  307.   str_ptr : str_ptr_type;
  308.   T1,T2   : integer;
  309. begin
  310.   { call a read error if the offset is too big }
  311.   T1 := offset div buflen;if T1>max_page then error(2,offset);
  312.   { if the string won't cross a buffer boundary, use Copy }
  313.   T2 := length(st);
  314.   if (T2+offset)<=buf_max then begin
  315.     { point str_ptr to the real address and copy the string }
  316.     offset := offset mod buflen;
  317.     str_ptr := ptr(seg(page[T1]^.data[offset]),ofs(page[T1]^.data[offset]));
  318.     str_ptr^ := st;
  319.     end
  320.   { else store the length and the characters, 1 by 1 }
  321.   else begin
  322.     put_byte(offset,T2); offset := offset + 1;
  323.     for T1:=1 to T2 do begin
  324.       put_byte(offset,ord(st[T1])); offset := offset + 1;
  325.     end;
  326.   end;
  327. end;
  328.  
  329. Procedure Interpret_Code;
  330. { interprets the op-code program, reutrning when PN is set to zero }
  331. { by the return from procedure 1. }
  332. const
  333.   { these codes are unassigned and therefore illegal. new ops may be added }
  334.   { by deleting them here and editing the CASE for this procedure to point }
  335.   { to the new handler. 15 is the EOP code and is assigned but illegal. }
  336.   illegal_ops: set of byte = [0,10,15,44,62,82..255];
  337. var
  338.   byte1               : byte; { gets the op-code byte }
  339.   temp1,temp2,temp3,I : integer; { local work variables }
  340.  
  341.   Procedure Load_Or_Store;
  342.   { performs transfers between memory and the (virtual) stack }
  343.   { Note- this routine does not check for invalid codes. }
  344.   begin
  345.     case byte1 of
  346.       1: begin { LDCI w }
  347.            temp1 := get_word(CP);            { get the immed. word }
  348.            put_word(SP,temp1); SP := SP + 2; { push it }
  349.            CP := CP + 2;                     { fix CP and return }
  350.          end;
  351.       2: begin { LDL w }
  352.            temp1 := get_word(CP) + LF; { get local offset + local frame ptr }
  353.            put_word(SP,get_word(temp1)); { push the data at that address }
  354.              SP := SP + 2;
  355.            CP := CP + 2;                 { fix CP and return }
  356.          end;
  357.       3: begin { LLA w }
  358.            { push local offset + lf }
  359.            put_word(SP,get_word(CP) + LF); SP := SP + 2;
  360.            CP := CP + 2;
  361.          end;
  362.       4: begin { LDB }
  363.            { replace the address with data without really popping/pushing }
  364.            temp1 := get_word(SP-2);
  365.            put_word(SP-2,(get_word(temp1) and 255));
  366.          end;
  367.       5: begin { LDO w }
  368.            temp1 := get_word(CP) + GF;  { get the address + global frame ptr }
  369.            put_word(SP,get_word(temp1)); SP := SP + 2; { push it }
  370.            CP := CP + 2;
  371.          end;
  372.       6: begin { LAO w }
  373.            { push the global offset + gf }
  374.            put_word(SP,get_word(CP) + GF); SP := SP + 2;
  375.            CP := CP + 2;
  376.          end;
  377.    8..9: begin { LOD b,w or LOA b,w }
  378.            { get the number of levels to back up and trace back }
  379.            { through static links to get the new LF in temp2 }
  380.            temp1 := get_byte(CP); temp2 := LF;
  381.            while temp1>0 do begin
  382.              temp2 := get_word(temp2-6);
  383.              temp1 := temp1 - 1;
  384.            end;
  385.            { get the offset in temp1 and point CP to the next op byte }
  386.            temp1 := get_word(CP); CP := CP + 2;
  387.            { push the data for op 8 or the address for op 9 }
  388.            if byte1=8 then put_word(SP,get_word(temp1+temp2))
  389.              else put_word(SP,(temp1+temp2));
  390.            SP := SP + 2;
  391.          end;
  392.      11: begin { STO }
  393.            SP := SP - 4; temp1 := get_word(SP+2); { pop the data }
  394.            { move it into the indirectly popped address and return }
  395.            put_word(get_word(SP),temp1);
  396.          end;
  397.      12: begin { SINDO }
  398.            { replace the address with data without pop/push }
  399.            { similar to op 4 but without masking the high byte }
  400.            temp1 := get_word(SP-2); put_word(SP-2,get_word(temp1));
  401.          end;
  402.     end;
  403.   end; { load_or_store }
  404.  
  405.   Procedure String_Assignment;
  406.   { basic string assignment }
  407.   begin
  408.     case byte1 of
  409.       13: begin { LCA b,<chars> }
  410.             { loads the address of a string starting at <CP> }
  411.             put_word(SP,CP); SP := SP + 2; { push the string address }
  412.             temp1 := get_byte(CP);         { get the number of chars }
  413.             CP := CP + temp1;  { point CP past the string and return }
  414.           end;
  415.       14: begin { SAS }
  416.             { assigns string at <TOS> to string at <TOS-1> }
  417.             { get the source length by reference from the stack. temp1 }
  418.             { is the source length, temp2 is the source address, and }
  419.             { temp3 is the destination address. }
  420.             SP := SP - 2; temp1 := get_word(SP); temp2 := temp1 + 1;
  421.             temp1 := get_byte(temp1);
  422.  
  423.             SP := SP - 2; temp3 := get_word(SP); { pop the dest. address  }
  424.             put_byte(temp3,temp1);          { dest length = source length }
  425.             while temp1>0 do begin                  { move the chars over }
  426.               put_byte(temp3,get_byte(temp2));
  427.               temp1 := temp1 - 1;
  428.             end;
  429.           end;
  430.     end;
  431.   end; { string_assignment }
  432.  
  433.   Procedure Logical_Operator;
  434.   { performs logical operations on TOS and TOS-1. when 2 words are involved, }
  435.   { SP is decremented and the data are manipulated on the stack to avoid }
  436.   { using intermediate variables. }
  437.   begin
  438.     case byte1 of
  439.       16: begin { AND }
  440.             SP := SP - 2; put_word(SP-2,(get_word(SP-2) and get_word(SP)));
  441.           end;
  442.       17: begin { OR }
  443.             SP := SP - 2; put_word(SP-2,(get_word(SP-2) or get_word(SP)));
  444.           end;
  445.       18: begin { NOT }
  446.             { only 1 word, so SP stays the same }
  447.             put_word(SP-2,(not get_word(SP-2)));
  448.           end;
  449.     end;
  450.   end; { logical_operator }
  451.  
  452.   Procedure Int_Math;
  453.   { performs integer math operations on TOS and TOS-1.  as above, temporary }
  454.   { variables are avoided. }
  455.   var
  456.     rtemp1: real; { work variable used to avoid integer math errors }
  457.   begin
  458.     case byte1 of
  459.       19: begin { ADI }
  460.             { pop TOS and add it to TOS-1 }
  461.             SP := SP - 2; put_word(SP-2,(get_word(SP-2) + get_word(SP)));
  462.           end;
  463.       20: begin { NGI }
  464.             put_word(SP-2,(not get_word(SP-2)));
  465.           end;
  466.       21: begin { SBI }
  467.             { pop TOS and subtract it from TOS-1 }
  468.             SP := SP - 2; put_word(SP-2,(get_word(SP-2) - get_word(SP)));
  469.           end;
  470.       22: begin { MPI }
  471.             { integer multiply TOS and TOS-1. error on signed int. overflow }
  472.             SP := SP - 2; rtemp1 := get_word(SP-2) * get_word(SP);
  473.             if abs(rtemp1)>maxint then error(5,0)
  474.               else put_word(SP-2,round(rtemp1));
  475.           end;
  476.       23: begin { DVI }
  477.             { pop TOS and signed integer divide TOS-1 by it. error on signed }
  478.             { integer out of range, crash if result is out of real range. }
  479.             SP := SP - 2; rtemp1 := get_word(SP-2) / get_word(SP);
  480.             if abs(rtemp1)>maxint then error(6,0)
  481.               else put_word(SP-2,trunc(rtemp1));
  482.           end;
  483.       45: begin { MODI }
  484.             { TOS-1 mod TOS }
  485.             SP := SP - 2; put_word(SP-2,(get_word(SP-2) mod get_word(SP)));
  486.           end;
  487.       80: begin { INCL w }
  488.             temp1 := get_word(CP) + LF;        { get the local address }
  489.             put_word(temp1,get_word(temp1)+1); { increment w/o another }
  490.             CP := CP + 2;                      {  temp and return. }
  491.           end;
  492.       81: begin { DECL w }
  493.             temp1 := get_word(CP) + LF;        { get the local address }
  494.             put_word(temp1,get_word(temp1)+1); { decrement w/o another }
  495.             CP := CP + 2;                      {  temp and return. }
  496.           end;
  497.     end;
  498.   end; { int_math }
  499.  
  500.   Procedure Array_index;
  501.   { these op-codes translate an array index into an address offset }
  502.   begin
  503.     case byte1 of
  504.       24: begin { IND }
  505.             { TOS-1 is the base of an int array, TOS is the index. the }
  506.             { address of the element = <TOS-> + <TOS>*2. }
  507.             SP := SP - 2;
  508.             put_word(SP-2,(get_word(SP-2) + get_word(SP)*2));
  509.           end;
  510.       48: begin { IXA b }
  511.             { as IND except the element size in 'b' is used instead of 2 }
  512.             SP := SP - 2;
  513.             put_word(SP-2,(get_word(SP-2) + get_word(SP)*get_byte(CP)));
  514.           end;
  515.     end;
  516.   end; { array_index }
  517.  
  518.   Procedure Int_Compare;
  519.   { compare signed integers TOS and TOS-1 and push -1 if the result is }
  520.   { true, 0 if it is false. }
  521.   var
  522.     test: boolean;
  523.   begin
  524.     test := false;
  525.     case byte1 of
  526.       25: begin { EQUI }
  527.             SP := SP - 2;
  528.             test := (get_word(SP-2) = get_word(SP));
  529.           end;
  530.       26: begin { NEQI }
  531.             SP := SP - 2;
  532.             test := (get_word(SP-2) <> get_word(SP));
  533.           end;
  534.       27: begin { LEQI }
  535.             SP := SP - 2;
  536.             test := (get_word(SP-2) <= get_word(SP));
  537.           end;
  538.       28: begin { LESI }
  539.             SP := SP - 2;
  540.             test := (get_word(SP-2) < get_word(SP));
  541.           end;
  542.       29: begin { GEQI }
  543.             SP := SP - 2;
  544.             test := (get_word(SP-2) >= get_word(SP));
  545.           end;
  546.       30: begin { GTRI }
  547.             SP := SP - 2;
  548.             test := (get_word(SP-2) > get_word(SP));
  549.           end;
  550.     end;
  551.     if test=true then put_word(SP-2,-1)
  552.       else put_word(SP-2,0);
  553.   end; { int_compare }
  554.  
  555.   Procedure Str_Compare;
  556.   { compares character strings for equ, gtr, les, etc. by copying them }
  557.   { into Turbo strings and using pascal string compares. }
  558.   var
  559.     str_ptr : str_ptr_type;
  560.     work    : anystring;
  561.     t4      : integer;
  562.     test    : boolean;
  563.   begin
  564.     test := false;
  565.     { pop @s1 and @s2 into temp1 and temp2 respectively }
  566.     SP := SP - 4; temp1 := get_word(SP); temp2 := get_word(SP+2);
  567.     { point to them }
  568.     str_ptr := Get_Str_Ptr(temp1); work := str_ptr^;
  569.     str_ptr := Get_Str_Ptr(temp2);
  570.  
  571.     case byte1 of
  572.       31: begin { EQUSTR }
  573.             test := (work = str_ptr^);
  574.           end;
  575.       32: begin { NEQSTR }
  576.             test := (work <> str_ptr^);
  577.           end;
  578.       33: begin { LEQSTR }
  579.             test := (work <= str_ptr^);
  580.           end;
  581.       34: begin { LESSTR }
  582.              test := (work < str_ptr^);
  583.           end;
  584.       35: begin { GEQSTR }
  585.              test := (work >= str_ptr^);
  586.           end;
  587.       36: begin { GTRSTR }
  588.              test := (work > str_ptr^);
  589.           end;
  590.     end;
  591.     if test=true then put_word(SP-2,-1)
  592.       else put_word(SP-2,0);
  593.   end; { str_compare }
  594.  
  595.   Procedure Jump;
  596.   { conducts conditional and unconditional jumps }
  597.   begin
  598.     case byte1 of
  599.       37: begin { UJP w }
  600.             { unconditional jump to CP + w }
  601.             CP := CP + 2 + get_word(CP);
  602.           end;
  603.       38: begin { FJP w }
  604.             { jump only if TOS = 0 }
  605.             SP := SP - 2;
  606.             if get_word(SP)=0 then CP := CP + get_word(CP);
  607.             CP := CP + 2;
  608.           end;
  609.       39: begin { XJP w1,w2,w3}
  610.             { implements CASE. TOS is the variable, w1 is the min value,  }
  611.             { w2 is the max value, and w3 is the offset to the last op    }
  612.             { before the jump table (always a 'UJP w'). Note: The odd     }
  613.             { design of Augusta's case makes it harder than it has to be. }
  614.  
  615.             { temp3=X, temp2=min, temp3=max }
  616.             SP := SP - 2; temp3 := get_word(SP);
  617.             temp1 := get_word(CP); temp2 := get_word(CP+2);
  618.  
  619.             { CP-> start of the jump table (a UJP to the OTHERS code) }
  620.             CP := CP + get_word(CP+4) + 5;
  621.  
  622.             { if the var is in range, CP->address of that table entry + }
  623.             { the word there + 2 }
  624.             if temp3 in[temp1..temp2] then begin
  625.               CP := CP + 3 + 2*(temp3-temp1);
  626.               CP := CP + 2 + get_word(CP);
  627.             end;
  628.           end;
  629.     end;
  630.   end; { jump }
  631.  
  632.   Procedure Call_Or_Return;
  633.   { processes calls and returns to procedures and functions }
  634.   begin
  635.     case byte1 of
  636.       40: begin { CLP b }
  637.             { get the proc number and push the frame mark }
  638.             I := get_byte(CP);
  639.             put_word(SP,proctable[I].level); { new level }
  640.             put_word(SP+2,PN);               { old PN }
  641.             put_word(SP+4,CP);               { return address }
  642.             put_word(SP+6,CB);               { old CB }
  643.             put_word(SP+8,LF);               { static link }
  644.             put_word(SP+10,LF);              { dynamic link }
  645.             put_word(SP+12,proctable[I].parm_bytes);
  646.             SP := SP + 14; LF := SP;
  647.             CP := proctable[I].offset; PN := I; CB := CP;
  648.  
  649.             { allocate stack for local vars }
  650.             while SP<(LF+proctable[I].local_var_bytes) do begin
  651.               put_word(SP,0); SP := SP + 2;
  652.             end;
  653.             if Odd(proctable[I].local_var_bytes) then SP := SP - 1;
  654.           end;
  655.       41: begin { CGP b }
  656.             I := get_byte(CP);
  657.             if I>0 then put_word(SP,proctable[I].level) { new level }
  658.               else put_word(SP,0);
  659.             put_word(SP+2,PN);               { old PN }
  660.             if I>0 then put_word(SP+4,CP)    { return address }
  661.               else put_word(SP+4,-1);
  662.             put_word(SP+6,CB);               { old CB }
  663.             put_word(SP+8,GF);               { global frame }
  664.             put_word(SP+10,LF);
  665.             put_word(SP+12,proctable[I].parm_bytes);
  666.             SP := SP + 14; LF := SP;
  667.             CP := proctable[I].offset; PN := I; CB := CP;
  668.  
  669.             { allocate stack for local vars }
  670.             while SP<(LF+proctable[I].local_var_bytes) do begin
  671.               put_word(SP,0); SP := SP + 2;
  672.             end;
  673.             if Odd(proctable[I].local_var_bytes) then SP := SP - 1;
  674.           end;
  675.       46: begin { CIP b }
  676.             I := get_byte(CP);
  677.             put_word(SP,proctable[I].level); { new level }
  678.             put_word(SP+2,PN);               { old PN }
  679.             put_word(SP+4,CP);               { return address }
  680.             put_word(SP+6,CB);               { old CB }
  681.             { trace back static links until either a lower level frame }
  682.             {  or the global frame is found }
  683.             temp1 := get_word(LF-6);
  684.             repeat
  685.               temp2 := get_word(temp1-14);
  686.               if temp2<=proctable[I].level then temp1 := get_word(temp1-6);
  687.             until (temp2=1) or (temp2>proctable[I].level);
  688.             put_word(SP+8,temp1);            { static link }
  689.             put_word(SP+10,LF);              { dynamic link }
  690.             put_word(SP+12,proctable[I].parm_bytes);
  691.             SP := SP + 14; LF := SP;
  692.             CP := proctable[I].offset; PN := I; CB := CP;
  693.  
  694.             { allocate stack for local vars }
  695.             while SP<(LF+proctable[I].local_var_bytes) do begin
  696.               put_word(SP,0); SP := SP + 2;
  697.             end;
  698.             if Odd(proctable[I].local_var_bytes) then SP := SP - 1;
  699.           end;
  700.       43: begin { RET }
  701.             SP := LF - 14 - get_word(LF-2)*2; { pop 7 words + any parms }
  702.             CB := get_word(LF-8);             { restore the machine regs }
  703.             CP := get_word(LF-10);            { from the stack frame info }
  704.             PN := get_word(LF-12);
  705.             LF := get_word(LF-4);             { restore LF last and return }
  706.           end;
  707.       47: begin { RNP }
  708.             temp1 := get_word(SP-2); { save <TOS> for return }
  709.             { restore as above but saving a word for the TOS return value }
  710.             SP := LF - 12 - get_word(LF-2)*2;
  711.             CB := get_word(LF-8); CP := get_word(LF-10);
  712.             PN := get_word(LF-12); LF := get_word(LF-4);
  713.             { put the return value in the saved word and return }
  714.             put_word(SP-2,temp1);
  715.           end;
  716.     end;
  717.   end;
  718.  
  719.   Procedure Short_Load;
  720.   { single-byte op codes to load local data or a constant. }
  721.   { the stack pointer is incremented at the end to save code }
  722.   begin
  723.     case byte1 of
  724.       49..56: begin { SLDL0..SLDL7 }
  725.                 { short load local word data at offset 0-7 }
  726.                 temp1 := byte1 - 49 + LF;
  727.                 put_word(SP,get_word(temp1));
  728.               end;
  729.           57: begin { SLDO b }
  730.                 { load global word data at offset 'b' }
  731.                 temp1 := get_byte(CP) + GF;
  732.                 put_word(SP,get_word(temp1));
  733.               end;
  734.           58: begin { SLAO b }
  735.                 { load address of global offset 'b' }
  736.                 put_word(SP,(get_byte(CP)+GF));
  737.               end;
  738.           59: begin { SLLA b }
  739.                 { load address of local offset 'b' }
  740.                 put_word(SP,(get_byte(CP)+LF));
  741.               end;
  742.           60: begin { SLDL b }
  743.                 { load data at local offset 'b' }
  744.                 temp1 := get_byte(CP) + LF;
  745.                 put_word(SP,get_word(temp1));
  746.               end;
  747.           61: begin { SLDC b }
  748.                 { load constant 'b'}
  749.                 put_word(SP,get_byte(CP));
  750.               end;
  751.           63: begin { SLDCN1 }
  752.                 { load -1 }
  753.                 put_word(SP,-1);
  754.               end;
  755.       64..79: begin { SLDC0..SLDC15 }
  756.                 { load a constant in the range 0..15 }
  757.                 put_word(SP,(byte1 - 64));
  758.               end;
  759.     end;
  760.     SP := SP + 2;
  761.   end; { short_load }
  762.  
  763.   Procedure System_Call;
  764.   { handles input/output for the augusta program through procedure calls }
  765.   var
  766.     Str_Ptr : str_ptr_type; { ptr to real address of a string parm }
  767.     Ch      : char;         { temporary var for character reads }
  768.     t4,t5   : integer;      { extra work vars }
  769.   begin
  770.     byte1 := get_byte(CP); { get the function number }
  771.     case byte1 of
  772.        1: begin {GETSTR}
  773.             { pop the offset}
  774.             SP := SP - 2; temp1 := get_word(SP);
  775.             { temp2=page, temp3=index into the page }
  776.             temp2 := temp1 div buflen; temp3 := temp1 mod buflen;
  777.             { if it's out of range call write error }
  778.             if temp2>max_page then error(2,temp1);
  779.  
  780.             { else read the string and store it }
  781.             read(work_string);
  782.             store_str(temp1,work_string);
  783.           end;
  784.      2,8: begin {PUTLINE, PUTSTR}
  785.             { uses pointers as above.  1st get the offset,page & index }
  786.             SP := SP - 2; temp1 := get_word(SP);
  787.             { point str_ptr to the string and call writeln }
  788.             str_ptr := Get_Str_Ptr(temp1);
  789.             write(str_ptr^);
  790.             if byte1=2 then writeln;
  791.           end;
  792.        3: begin {GETINT}
  793.             readln(I);
  794.             SP := SP - 2; put_word(get_word(SP),I);
  795.           end;
  796.        4: begin {PUTINT}
  797.             SP := SP - 2; write(get_word(SP));
  798.           end;
  799.        5: begin {GETCHAR}
  800.             SP := SP - 2; temp1 := get_word(SP);
  801.             read(ch); put_word(temp1,ord(ch));
  802.           end;
  803.        6: begin {PUTCHAR}
  804.             SP := SP - 2; temp1 := get_word(SP);
  805.             write(char(get_word(temp1)));
  806.           end;
  807.        7: writeln; {NEWLINE}
  808.        9: begin {PEEK}
  809.             temp1 := get_word(SP-2); temp1 := Mem[DSeg:temp1];
  810.             put_word(SP-2,temp1);
  811.           end;
  812.       10: begin {POKE}
  813.             SP := SP - 4; temp1 := get_word(SP+2); temp2 := get_word(SP);
  814.             Mem[DSeg:temp2] := temp1;
  815.           end;
  816.       11: begin {SUBSTR}
  817.             { temp1:=@s2, temp2:=@s1, temp3:=len, T4:=start }
  818.             SP := SP - 8; temp1 := get_word(SP+2); temp2 := get_word(SP);
  819.             temp3 := get_word(SP+6); T4 := get_word(SP+4); { len & start }
  820.             str_ptr := get_str_ptr(temp1);
  821.             work_string := copy(str_ptr^,T4,Temp3);
  822.             store_str(temp2,work_string);
  823.           end;
  824.   12..13: begin {MOVELEFT, MOVERIGHT}
  825.             SP := SP - 6;
  826.             temp1 := get_word(SP+4); temp2 := get_word(SP+2);
  827.             temp3 := get_word(SP); temp3 := get_byte(temp3);
  828.             while temp1>1 do begin
  829.               put_word(temp2,temp3); temp1 := temp1 - 2;
  830.               if byte1=12 then temp2 := temp2 + 2
  831.                 else temp2 := temp2 - 2;
  832.             end;
  833.             if temp1>0 then put_byte(temp2,temp3);
  834.           end;
  835.       28: begin {CHAR}
  836.             SP := SP - 2; temp1 := get_word(SP); temp2 := get_word(SP-2);
  837.             { if pos>len(s1) then char:=0 else char:=s1[pos] }
  838.             if temp1>get_byte(temp2) then
  839.               put_word(SP-2,0)
  840.             else begin
  841.               temp2 := temp2 + temp1 - 1; temp1 := get_byte(temp2);
  842.               put_word(SP-2,temp1);
  843.             end;
  844.           end;
  845.       30: begin {PUTBOOL}
  846.             SP := SP - 2;
  847.             if get_word(SP)=0 then write(false)
  848.               else write(true);
  849.           end;
  850.       34: begin {APPEND}
  851.             { pop the addresses of s2 and s1 respectively }
  852.             SP := SP - 4; temp1 := get_word(SP+2); temp2 := get_word(SP);
  853.             { get len(s2) and len(s1) and increment the pointer to each }
  854.             temp3 := get_byte(temp1); I := get_byte(temp2);
  855.             { len(s1) := len(s1) + len(s2), point to 1st empty spot in s1 }
  856.             put_byte(temp2-1,temp3+I); temp2 := temp2 + I;
  857.             { transfer s2 onto s1 char by char }
  858.             while temp3>0 do begin
  859.               I := get_byte(temp1); put_byte(temp2,I); temp2 := temp2 + 1;
  860.             end;
  861.           end;
  862.       35: begin {ASSIGN}
  863.             { get the address of s1[pos] }
  864.             SP := SP - 6; temp1 := get_word(SP+4) + get_word(SP+2);
  865.             { get value and put it into the string }
  866.             temp2 := get_word(SP); put_byte(temp1,temp2);
  867.           end;
  868.       40: begin {KEYPRESS}
  869.             if keypressed then put_word(SP,-1) else put_word(SP,0);
  870.             SP := SP + 2;
  871.           end;
  872.       else error(7,byte1);
  873.     end;
  874.   end; { system_call }
  875.  
  876. begin
  877.  Repeat
  878.  
  879.   { get an op-code byte from the buffer }
  880.   byte1 := get_byte(CP);
  881.  
  882.   { if it's an illegal code, print an error and halt }
  883.   if byte1 in illegal_ops then error(8,byte1)
  884.  
  885.   { if it's a legal code, branch to the procedure handling that op class }
  886.   else begin
  887.     case byte1 of               { Note- indented procedures are repeats from }
  888.        1..12: load_or_store;    {  a previous line. }
  889.       13..14: string_assignment;
  890.         { 15:  this is a special end-of-proc code, assigned but not executed }
  891.       16..18: logical_operator;
  892.       19..23: int_math;
  893.           24: array_index;
  894.       25..30: int_compare;
  895.       31..36: str_compare;
  896.       37..39: jump;
  897.       40..41: call_or_return;
  898.           42: system_call;
  899.       43..44:   call_or_return;
  900.           45:   int_math;
  901.       46..47:   call_or_return;
  902.           48:   array_index;
  903.       49..79: short_load;
  904.       80..81:   int_math;
  905.     end;
  906.   end;
  907.  
  908.  Until PN=0;
  909. end; { interpret_code }
  910.  
  911.  
  912. BEGIN
  913.  
  914.   { load the augusta program into a linked sequence of buffers }
  915.   load_program;
  916.  
  917.   { initialize the stack at the 1st byte after the program }
  918.   SB := header.code_size + 1; SP := SB;
  919.  
  920.   { start execution by faking a call to proc 1 from proc 0 (which doesn't }
  921.   { exist). when the program ends with a return, PN will be set to zero,  }
  922.   { signalling the interpreter to stop. }
  923.   put_word(SP,$0129); { CGP 1 p-code, last byte first }
  924.   PN := 0; CP := SP; CB := CP;
  925.   GF := SP + 14; LF := GF;
  926.  
  927.   { process code until the program terminates itself }
  928.   interpret_code;
  929.  
  930.   { free up all the heap space allocated to the program }
  931.   for pn:=0 to max_page do freemem(page[pn],sizeof(buf_type));
  932.  
  933. END.
  934.